home *** CD-ROM | disk | FTP | other *** search
/ TOS Silver 2000 / TOS Silver 2000.iso / programm / MM2_DEV / S / COMP / TEST / RAYTRACE / RAYTRACE.M < prev   
Encoding:
Modula Implementation  |  1991-03-28  |  11.1 KB  |  374 lines
  1. IMPLEMENTATION MODULE RayTrace;
  2.  
  3. (*$ R- *)
  4.  
  5. FROM MathLib0 IMPORT sqrt,power,entier;
  6. FROM LineA    IMPORT LineAVars, PtrLineAVars,
  7.                      PutPixel, LineAVariables;
  8. FROM GrafBase IMPORT WritingMode,Pnt;
  9. FROM XBIOS    IMPORT GetResolution;
  10.  
  11. VAR   vars : PtrLineAVars;
  12.       res,y_res: INTEGER;
  13.  
  14.       
  15. (* ------------------------------------------------ *)
  16.  
  17. PROCEDURE Ebene1schn (VAR Pktz,Vecz:LONGREAL ; VAR Index:INTEGER ;
  18.                       VAR Lambda:LFeld );
  19.    
  20. BEGIN
  21.   (* Schnitt Basisebene - Blickgerade *)
  22.   INC (Index);
  23.   IF (Vecz=0.0) THEN
  24.     Lambda[Index]:=Unendlich
  25.   ELSE
  26.     Lambda[Index]:=-Pktz/Vecz
  27.   END (* IF *)
  28. END Ebene1schn;
  29.  
  30.  
  31. PROCEDURE Ebene1weiter (VAR Pktx,Pkty,Vecx,Vecy:LONGREAL ;
  32.                         VAR Lambda:LFeld ;
  33.                         VAR Index,Farbe,Untersuchungsende:INTEGER );
  34.                         
  35. VAR Spktx,Spkty:LONGREAL;
  36.                         
  37. BEGIN
  38.   (* Farbe errechnen, die sich durch Schnitt mit Ebene 1 ergibt *)
  39.   (* Schnittpkt.-Koordinaten *)
  40.   Spktx:=Pktx+Lambda[Index]*Vecx;
  41.   Spkty:=Pkty+Lambda[Index]*Vecy;
  42.   (* Farbe an der Stelle des Schnittpunktes ermitteln (Karo-Muster) *)
  43.   IF ((ABS(Spktx)>5.0) OR (ABS(Spkty)>5.0)) THEN
  44.     Farbe:=0
  45.   ELSE
  46.     (* ---- In der folgenden Zeile tritt der Fehler auf ---- *)
  47.     Farbe:=SHORT(entier(Spktx*1.6))+SHORT(entier(Spkty*1.6))+32;
  48.     Farbe:=SHORT (VAL(LONGINT,Spktx*1.6))+SHORT (VAL(LONGINT,Spkty*1.6))+32;
  49.     Farbe:=(Farbe MOD 2)+1
  50.   END; (* IF *)
  51.   Untersuchungsende:=-1
  52. END Ebene1weiter;
  53.  
  54. PROCEDURE Kugel1schn (VAR Pktx,Pkty,Pktz,Vecx,Vecy,Vecz,
  55.                           Kug1pktx,Kug1pkty,Kug1pktz,Kug1rquad:LONGREAL;
  56.                       VAR Lambda:LFeld;
  57.                       VAR Index :INTEGER );
  58.                       
  59. VAR A,B,C,D,E,Disk:LONGREAL;
  60.  
  61. BEGIN
  62.   (* Schnitt Kugel - Blickgerade  *)
  63.   INC (Index);
  64.   A:=Pktx-Kug1pktx;
  65.   B:=Pkty-Kug1pkty;
  66.   C:=Pktz-Kug1pktz;
  67.   D:=power(Vecx,2.0)+power(Vecy,2.0)+power(Vecz,2.0);
  68.   E:=Vecx*A+Vecy*B+Vecz*C;
  69.   Disk:=power(E,2.0)-D*(power(A,2.0)+power(B,2.0)+power(C,2.0)-Kug1rquad);
  70.   IF (Disk<0.0) THEN
  71.     (* kein Schnittpunkt vorhanden *)
  72.     Lambda[Index]:=Unendlich
  73.   ELSE
  74.     Lambda[Index]:=(-E-sqrt(Disk))/D;
  75.     IF (Lambda[Index]<0.001) THEN
  76.       (* Schnittpunkt in falscher Richtung vorhanden, unbrauchbar *)
  77.       Lambda[Index]:=Unendlich
  78.     END (* IF *)
  79.   END (* IF *)
  80. END Kugel1schn;
  81.  
  82.  
  83. PROCEDURE Kugel1weiter (VAR Pktx,Pkty,Pktz,Vecx,Vecy,Vecz,
  84.                             Kug1pktx,Kug1pkty,Kug1pktz,Kug1rquad:LONGREAL;
  85.                         VAR Lambda:LFeld;
  86.                         VAR Index,Farbversch:INTEGER );
  87.                         
  88. VAR F,Mvecx,Mvecy,Mvecz:LONGREAL;
  89.  
  90. BEGIN
  91.   (* neue Punkt-Richtungs-Gerade errechnen (durch Spiegelung) *)
  92.   (* Schnittpunkt *)
  93.   Pktx:=Pktx+Lambda[Index]*Vecx;
  94.   Pkty:=Pkty+Lambda[Index]*Vecy;
  95.   Pktz:=Pktz+Lambda[Index]*Vecz;
  96.   (* Vektor Mittelpunkt-Schnittpunkt *)
  97.   Mvecx:=Pktx-Kug1pktx;
  98.   Mvecy:=Pkty-Kug1pkty;
  99.   Mvecz:=Pktz-Kug1pktz;
  100.   F:=(Mvecx*Vecx+Mvecy*Vecy+Mvecz*Vecz)/Kug1rquad;
  101.   (* neuer Richtungsvektor *)
  102.   Vecx:=Vecx-2.0*F*Mvecx;
  103.   Vecy:=Vecy-2.0*F*Mvecy;
  104.   Vecz:=Vecz-2.0*F*Mvecz;
  105.   INC(Farbversch,2)
  106. END Kugel1weiter;
  107.  
  108. PROCEDURE Ebene2schn ( VAR Pktx,Pkty,Pktz,Vecx,Vecy,Vecz,
  109.                            Zyl1pktx,Zyl1pkty,Zyl1rquad,Zyl1hoehe:LONGREAL ;
  110.                        VAR Lambda:LFeld;
  111.                        VAR Index :INTEGER );
  112.                        
  113. VAR Abstandquad,Xko,Yko:LONGREAL;
  114.                         
  115. BEGIN
  116.   (* Schnitt Ebene 2 (d.i. der Deckel des Zylinders) mit Blickgerade *)
  117.   INC (Index);
  118.   IF (Vecz=0.0) THEN
  119.     Lambda[Index]:=Unendlich
  120.   ELSE
  121.     Lambda[Index]:=(Zyl1hoehe-Pktz)/Vecz;
  122.     Xko:=Pktx+Lambda[Index]*Vecx;
  123.     Yko:=Pkty+Lambda[Index]*Vecy;
  124.     Abstandquad:=power((Zyl1pktx-Xko),2.0)+power((Zyl1pkty-Yko),2.0);
  125.     IF (Abstandquad>Zyl1rquad) THEN
  126.       Lambda[Index]:=Unendlich
  127.     END (* IF *)
  128.   END (* IF *)
  129. END Ebene2schn;
  130.  
  131.  
  132. PROCEDURE Ebene2weiter ( VAR Untersuchungsende,Farbe:INTEGER );
  133.  
  134. BEGIN
  135.   (* Farbe errechnen, die sich durch Schnitt mit Ebene 2 ergibt *)
  136.   Untersuchungsende:=-1;
  137.   Farbe:=4
  138. END Ebene2weiter;
  139.  
  140. PROCEDURE Glasz1schn (VAR Pktx,Pkty,Pktz,Vecx,Vecy,Vecz,
  141.                           Zyl1pktx,Zyl1pkty,Zyl1rquad,Zyl1hoehe:LONGREAL;
  142.                       VAR Lambda:LFeld;
  143.                       VAR Index :INTEGER );
  144.                       
  145. VAR A,B,C,D,E,Disk:LONGREAL;
  146.                       
  147. BEGIN
  148. (* Schnitt Glaszylinder - Blickgerade von außen *)
  149.   INC (Index);
  150.   A:=Pktx-Zyl1pktx;
  151.   C:=Pkty-Zyl1pkty;
  152.   D:=power(Vecx,2.0)+power(Vecy,2.0);
  153.   E:=Vecx*A+Vecy*C;
  154.   Disk:=power(E,2.0)-D*(power(A,2.0)+power(C,2.0)-Zyl1rquad);
  155.   IF (Disk<0.0) THEN
  156.     (* kein Schnittpunkt vorhanden *)
  157.     Lambda[Index]:=Unendlich
  158.   ELSE
  159.     Lambda[Index]:=(-E-sqrt(Disk))/D;
  160.     IF ((Lambda[Index]<0.001) OR (Pktz+Lambda[Index]*Vecz>Zyl1hoehe)) THEN
  161.       (* der Schnittpunkt ist entweder in der falschen Richtung oder *)
  162.       (* zu hoch, daher zweiten Schnittpunkt errechnen *)
  163.       Lambda[Index]:=(-E+sqrt(Disk))/D;
  164.       IF ((Lambda[Index]<=0.001) OR (Pktz+Lambda[Index]*Vecz>Zyl1hoehe)) THEN
  165.         (* auch der zweite Schnittpunkt entspricht nicht den Forderungen *)
  166.         Lambda[Index]:=Unendlich
  167.       END (* IF *)
  168.     END (* IF *)
  169.   END (* IF *)
  170. END Glasz1schn;
  171.  
  172.  
  173. PROCEDURE Glasz1weiter (VAR Pktx,Pkty,Pktz,Vecx,Vecy,Vecz,
  174.                             Zyl1pktx,Zyl1pkty,Zyl1rquad,
  175.                             Brechindex:LONGREAL;
  176.                         VAR Lambda:LFeld;
  177.                         VAR Index,Farbversch:INTEGER );
  178.                       
  179. VAR F,Veclenquad,Veclenquad1,Veclen,Veclen1,Projvecx,Projvecy,Projlenquad,
  180.     Projlen,Projlen1,Constquad,Laenge,Ende,Mvecx,Mvecy:LONGREAL;
  181.     
  182. BEGIN
  183.   (* neue Punkt-Richtungs-Gerade errechnen (durch Brechung) *)
  184.   Pktx:=Pktx+Lambda[Index]*Vecx;
  185.   Pkty:=Pkty+Lambda[Index]*Vecy;
  186.   Pktz:=Pktz+Lambda[Index]*Vecz;
  187.   (* Länge Blickvektor *)
  188.   Veclenquad:=power(Vecx,2.0)+power(Vecy,2.0);
  189.   Veclen:=sqrt(Veclenquad);
  190.   (* Vektor zur Drehachse des Zylinders *)
  191.   Mvecx:=Pktx-Zyl1pktx;
  192.   Mvecy:=Pkty-Zyl1pkty;
  193.   F:=(Mvecx*Vecx+Mvecy*Vecy)/Zyl1rquad;
  194.   (* Bilckvektor auf Mvec projezieren *)
  195.   Projvecx:=F*Mvecx;
  196.   Projvecy:=F*Mvecy;
  197.   Projlenquad:=power(Projvecx,2.0)+power(Projvecy,2.0);
  198.   Projlen:=sqrt(Projlenquad);
  199.   (* Konstante *)
  200.   Constquad:=Veclenquad-Projlenquad;
  201.   Veclen1:=Veclen*Brechindex;
  202.   Veclenquad1:=power(Veclen1,2.0);
  203.   IF (Veclenquad1<Constquad) THEN
  204.     (* Totalrefelxion *)
  205.     Ende:=-1.0
  206.   ELSE
  207.     (* Normale Brechung *)
  208.     Projlen1:=sqrt(Veclenquad1-Constquad);
  209.     (* Faktor für Verlängerung *)
  210.     Laenge:=Projlen1-Projlen;
  211.     (* neuer Richtungsvektor *)
  212.     Vecx:=Vecx+Laenge*Projvecx/Projlen;
  213.     Vecy:=Vecy+Laenge*Projvecy/Projlen;
  214.     Brechindex:=1.0/Brechindex;
  215.     INC(Farbversch)
  216.   END (* IF *)
  217. END Glasz1weiter;
  218.  
  219.  
  220. PROCEDURE Zylin1schn (VAR Pktx,Pkty,Pktz,Vecx,Vecy,Vecz,
  221.                           Zyl1pktx,Zyl1pkty,Zyl1hoehe,Zyl1rquad:LONGREAL;
  222.                       VAR Lambda:LFeld;
  223.                       VAR Index :INTEGER );
  224.                       
  225. VAR A,B,C,D,E,Disk,Hoehe:LONGREAL;
  226.  
  227. BEGIN
  228.   (* Schnitt Zylinder - Blickgerade *)
  229.   INC (Index);
  230.   A:=Pktx-Zyl1pktx;
  231.   B:=Pkty-Zyl1pkty;
  232.   D:=power(Vecx,2.0)+power(Vecy,2.0);
  233.   E:=Vecx*A+Vecy*B;
  234.   Disk:=power(E,2.0)-D*(power(A,2.0)+power(B,2.0)-Zyl1rquad);
  235.   IF (Disk<0.0) THEN
  236.     (* kein Schnittpunkt vorhanden *)
  237.     Lambda[Index]:=Unendlich
  238.   ELSE
  239.     Lambda[Index]:=(-E-sqrt(Disk))/D;
  240.     Hoehe:=Pktz+Vecz*Lambda[Index];
  241.     IF Hoehe>Zyl1hoehe THEN
  242.       (* Schnittpunkt liegt zu hoch *)
  243.       Lambda[Index]:=Unendlich
  244.     END (* IF *)
  245.   END (* IF *)
  246. END Zylin1schn;
  247.  
  248.  
  249. PROCEDURE Zylin1weiter (VAR Pktx,Pkty,Pktz,Vecx,Vecy,Vecz,
  250.                             Zyl1pktx,Zyl1pkty,Zyl1rquad:LONGREAL;
  251.                         VAR Lambda:LFeld;
  252.                         VAR Farbversch,Index:INTEGER );
  253.                         
  254. VAR F,Mvecx,Mvecy:LONGREAL;
  255.  
  256. BEGIN
  257.   (* neue Punkt-Richtungs-Gerade errechnen (ergibt sich durch Spiegelung) *)
  258.   Pktx:=Pktx+Lambda[Index]*Vecx;
  259.   Pkty:=Pkty+Lambda[Index]*Vecy;
  260.   Pktz:=Pktz+Lambda[Index]*Vecz;
  261.   Mvecx:=Pktx-Zyl1pktx;
  262.   Mvecy:=Pkty-Zyl1pkty;
  263.   F:=(Mvecx*Vecx+Mvecy*Vecy)/Zyl1rquad;
  264.   Vecx:=Vecx-2.0*F*Mvecx;
  265.   Vecy:=Vecy-2.0*F*Mvecy;
  266.   INC(Farbversch,2)
  267. END Zylin1weiter;
  268.  
  269.  
  270. PROCEDURE Drehk1schn (VAR Pktx,Pkty,Pktz,Vecx,Vecy,Vecz,
  271.                           Dk1pktx,Dk1pkty,Dk1stquad,Dk1hoehe:LONGREAL;
  272.                       VAR Lambda:LFeld;
  273.                       VAR Index :INTEGER );
  274.                       
  275. VAR A,B,C,D,E,Disk,Hoehe:LONGREAL;
  276.  
  277. BEGIN
  278.   (* Schnitt Drehkegel - Blickgerade *)
  279.   INC (Index);
  280.   A:=Pktx-Dk1pktx;
  281.   B:=Pkty-Dk1pkty;
  282.   C:=Pktz;
  283.   D:=power(Vecx,2.0)+power(Vecy,2.0)-power(Vecz,2.0)/Dk1stquad;
  284.   E:=Vecx*A+Vecy*B-Vecz*C/Dk1stquad;
  285.   Disk:=power(E,2.0)-D*(power(A,2.0)+power(B,2.0)-power(C,2.0)/Dk1stquad);
  286.   IF (Disk<0.0) THEN
  287.     (* kein Schnittpunkt vorhanden *)
  288.     Lambda[Index]:=Unendlich
  289.   ELSE
  290.     Lambda[Index]:=(-E-sqrt(Disk))/D;
  291.     Hoehe:=Pktz+Vecz*Lambda[Index];
  292.     IF (Hoehe>Dk1hoehe) THEN
  293.       (* Schnittpunkt zu hoch *)
  294.       Lambda[Index]:=Unendlich
  295.     END (* IF *)
  296.   END (* IF *)
  297. END Drehk1schn;
  298.  
  299.  
  300. PROCEDURE Drehk1weiter (VAR Pktx,Pkty,Pktz,Vecx,Vecy,Vecz,
  301.                             Dk1pktx,Dk1pkty,Dk1steig:LONGREAL;
  302.                         VAR Lambda:LFeld;
  303.                         VAR Index,Farbversch:INTEGER);
  304.                         
  305. VAR F,Radiusquad,Mvecx,Mvecy,Mvecz,Mlen:LONGREAL;
  306.  
  307. BEGIN
  308.   (* neue Punkt-Richtungs-Gerade errechnen (ergibt sich durch Spiegelung) *)
  309.   Pktx:=Pktx+Lambda[Index]*Vecx;
  310.   Pkty:=Pkty+Lambda[Index]*Vecy;
  311.   Pktz:=Pktz+Lambda[Index]*Vecz;
  312.   Mvecx:=Pktx-Dk1pktx;
  313.   Mvecy:=Pkty-Dk1pkty;
  314.   Radiusquad:=power(Mvecx,2.0)+power(Mvecy,2.0);
  315.   Mvecz:=-sqrt(Radiusquad)/Dk1steig;
  316.   Mlen:=Radiusquad+power(Mvecz,2.0);
  317.   F:=(Mvecx*Vecx+Mvecy*Vecy+Mvecz*Vecz)/Mlen;
  318.   Vecx:=Vecx-2.0*F*Mvecx;
  319.   Vecy:=Vecy-2.0*F*Mvecy;
  320.   Vecz:=Vecz-2.0*F*Mvecz;
  321.   INC(Farbversch,2)
  322. END Drehk1weiter;
  323.  
  324. PROCEDURE Plot_Sw (X,Y,Farbe:INTEGER);
  325.   (* Unterprogramm, um Pixel in 5 Graustufen zu zeichnen *)
  326.   (* Koordinaten in X/Y, Farbinformation in Farbe *)
  327.   (* Koordinaten verdoppeln *)
  328. BEGIN
  329.   X:=X*2;
  330.   Y:=Y*2;
  331.   IF Farbe>=1 THEN
  332.     PutPixel (Pnt(X,Y),1);
  333.     IF Farbe>=2 THEN
  334.       PutPixel (Pnt(X+1,Y+1),1);
  335.       IF Farbe>=3 THEN
  336.         PutPixel (Pnt(X+1,Y),1);
  337.         IF Farbe>=4 THEN
  338.           PutPixel (Pnt(X,Y+1),1)
  339.         END (* IF *)
  340.       END (* IF *)
  341.     END (* IF *)
  342.   END (* IF *)
  343. END Plot_Sw;
  344.  
  345.  
  346. PROCEDURE Plot (X,Y,Farbe:INTEGER);
  347.  
  348. BEGIN
  349.   PutPixel (Pnt(X,Y),VAL(CARDINAL,Farbe))
  350. END Plot;
  351.  
  352.  
  353. (* -------------------------------------------------- *)
  354.  
  355.  
  356. BEGIN
  357.   res:=GetResolution();    (* Auflösung bestimmen *)
  358.   CASE res OF
  359.              2:y_res:=399  (* ST Hoch   *)
  360.            | 4:y_res:=479  (* TT Mittel *)
  361.            ELSE HALT       (* Sonst Ende *)
  362.   END; (* Case *)
  363.   vars:=LineAVariables ();
  364.   WITH vars^ DO
  365.     writingMode:=replaceWrt;
  366.     plane1:=TRUE;
  367.     lineMask:=$FFFF;
  368.     lastLine:=TRUE;
  369.     clipping:=TRUE;
  370.     minClip:=Pnt(0,0);
  371.     maxClip:=Pnt(639,y_res)
  372.   END
  373. END RayTrace.
  374.